home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 051-060 / amok53 / oberon2.0 / demos / tetriz.mod < prev    next >
Text File  |  1993-11-04  |  10KB  |  411 lines
  1. MODULE Tetriz;
  2.  
  3. IMPORT I: Intuition,
  4.        g: Graphics,
  5.        e: Exec,
  6.        d: Dos,
  7.        au: Audio,
  8.        es: ExecSupport;
  9.  
  10. CONST
  11.   W = 10;   (* Spielfeldgröße *)
  12.   H = 20;
  13.   bw = 20;  (* Boxgröße *)
  14.   bh = 8;
  15.   w = bw*W; (* Fenstergröße *)
  16.   h = bh*H;
  17.  
  18. TYPE
  19.   LS = LONGSET;                 (* LONGSET = ARRAY 4,4 OF BOOLEAN *)
  20.   SteineFeld = ARRAY 7,4 OF LS;
  21.  
  22. CONST
  23.   S = SteineFeld(
  24.         LS{0..3},    LS{0,4,8,12}, LS{0..3},    LS{0,4,8,12},
  25.         LS{0..2,5},  LS{0,4,5,8},  LS{1,4..6},  LS{1,4,5,9},
  26.         LS{0..2,4},  LS{0,4,8,9},  LS{2,4..6},  LS{0,1,5,9},
  27.         LS{0..2,6},  LS{0,1,4,8},  LS{0,4..6},  LS{1,5,8,9},
  28.         LS{0,1,5,6}, LS{1,4,5,8},  LS{0,1,5,6}, LS{1,4,5,8},
  29.         LS{1,2,4,5}, LS{0,4,5,9},  LS{1,2,4,5}, LS{0,4,5,9},
  30.         LS{0,1,4,5}, LS{0,1,4,5},  LS{0,1,4,5}, LS{0,1,4,5});
  31.  
  32. VAR
  33.   Feld: ARRAY W,H OF INTEGER;
  34.  
  35.   nw: I.NewWindow;
  36.   window: I.WindowPtr;
  37.  
  38.   rp: g.RastPortPtr;
  39.  
  40.   MyMsgPtr: I.IntuiMessagePtr;
  41.   MyMsg: I.IntuiMessage;
  42.  
  43.   Lines: INTEGER;
  44.   HiScore: INTEGER;
  45.  
  46. CONST  (* $DataChip+ *)
  47.   RectTable = "\x7F\x80";
  48.   RectTableSize = 2;
  49.   AllocationMap = "\x01\x08\x02\x04";
  50.  
  51. VAR
  52.   AllocPort: e.MsgPortPtr;
  53.   AllocIOB:  au.IOAudioPtr;
  54.   AudioOpen: BOOLEAN;
  55.   AllocationMapPtr: POINTER TO ARRAY 4 OF CHAR;
  56.   RectTablePtr: POINTER TO ARRAY 2 OF CHAR;
  57.  
  58. TYPE
  59.   DoProc = PROCEDURE(x,y,c: INTEGER);
  60.  
  61. VAR
  62.   collCnt: INTEGER;
  63.   font: g.TextFontPtr;
  64.   fontName, winTitle: e.STRPTR;
  65.   attr: g.TextAttr;
  66.  
  67. (*-------------------------------------------------------------------------*)
  68. (* $Debug- *)
  69.  
  70. PROCEDURE * Box(x,y,c: INTEGER);
  71.  
  72. BEGIN
  73.   IF (x>=0) AND (y>=0) THEN
  74.     g.SetAPen(rp,c);
  75.     x := x*bw; y := y*bh;
  76.     g.RectFill(rp,x+1,y+1,x+(bw-2),y+(bh-1));
  77.   END;
  78. END Box;
  79.  
  80. PROCEDURE Do(s: LONGSET; x,y,c: INTEGER; what: DoProc);
  81. VAR
  82.   i,j: INTEGER;
  83.   X,Y: INTEGER;
  84. BEGIN
  85.   i := 0;
  86.   REPEAT
  87.     j := 0;
  88.     REPEAT
  89.       IF 4*i+j IN s THEN
  90.         X := x+j; Y := y+i;
  91.         CASE X OF 0..W-1: CASE Y OF 0..H-1: what(X,Y,c) ELSE END ELSE END;
  92.       END;
  93.       INC(j);
  94.     UNTIL j=4;
  95.     INC(i);
  96.   UNTIL i=4;
  97. END Do;
  98.  
  99.  
  100. PROCEDURE * CollCnt(x,y,c: INTEGER);
  101. BEGIN IF Feld[x,y]=0 THEN INC(collCnt) END END CollCnt;
  102.  
  103. PROCEDURE Collide(s: LONGSET; x,y: INTEGER): BOOLEAN;
  104. BEGIN
  105.   IF y<0 THEN RETURN FALSE END;
  106.   collCnt := 0;
  107.   Do(s,x,y,0,CollCnt);
  108.   RETURN collCnt#4;
  109. END Collide;
  110.  
  111.  
  112. PROCEDURE * AddIt(x,y,c: INTEGER);
  113. BEGIN Feld[x,y] := c END AddIt;
  114.  
  115.  
  116. PROCEDURE Draw(s: LONGSET; x,y,c: INTEGER);
  117. BEGIN Do(s,x,y,c,Box) END Draw;
  118.  
  119.  
  120. PROCEDURE WriteInt(i: INTEGER);
  121. VAR
  122.   s: ARRAY 4 OF CHAR;
  123.   c: INTEGER;
  124. BEGIN
  125.   c := 0;
  126.   REPEAT
  127.     s[3-c] := CHR(30H + i MOD 10);
  128.     i := i DIV 10;
  129.     INC(c);
  130.   UNTIL c=4;
  131.   g.SetAPen(rp,1); g.SetBPen(rp,0); g.SetDrMd(rp,g.jam2);
  132.   g.Text(rp,s,4);
  133. END WriteInt;
  134.  
  135.  
  136. PROCEDURE CheckLine();
  137. VAR
  138.   x,y,y2: INTEGER;
  139.   lines: ARRAY H OF INTEGER;
  140.   lcnt: INTEGER;
  141. BEGIN
  142.   lcnt := 0;
  143.   y := 0;
  144.   REPEAT
  145.     x := 0;
  146.     LOOP
  147.       IF Feld[x,y]=0 THEN EXIT END;
  148.       INC(x);
  149.       IF x=W THEN lines[lcnt] := 8*y; INC(lcnt); EXIT END;
  150.     END;
  151.     INC(y);
  152.   UNTIL y=H;
  153.   IF lcnt#0 THEN
  154.  
  155.     INC(Lines,lcnt);
  156.     g.Move(rp,56,h+8); WriteInt(Lines);
  157.  
  158.     es.BeginIO(AllocIOB);
  159.     g.SetDrMd(rp,SHORTSET{g.complement});
  160.     x := 0;
  161.     REPEAT
  162.       y := 0;
  163.       REPEAT
  164.         g.RectFill(rp,0,lines[y]+1,w-1,lines[y]+7);
  165.         INC(y);
  166.       UNTIL y=lcnt;
  167.       INC(x);
  168.       d.Delay(3);
  169.     UNTIL x=8;
  170.     g.SetDrMd(rp,g.jam1);
  171.     IF e.WaitIO(AllocIOB)=0 THEN END;
  172.  
  173.     y := 19; y2 := 19; DEC(lcnt);
  174.     LOOP
  175.       IF y2<0 THEN EXIT END;
  176.       WHILE (lcnt>=0) AND (lines[lcnt]=8*y2) DO DEC(y2); DEC(lcnt) END;
  177.       IF y2<0 THEN EXIT END;
  178.       x := 0;
  179.       REPEAT
  180.         Feld[x,y] := Feld[x,y2];
  181.         INC(x);
  182.       UNTIL x=W;
  183.       DEC(y); DEC(y2);
  184.     END;
  185.     WHILE y>=0 DO
  186.       x := 0;
  187.       REPEAT
  188.         Feld[x,y] := 0;
  189.         INC(x);
  190.       UNTIL x=W;
  191.       DEC(y)
  192.     END;
  193.     y := 0;
  194.     REPEAT
  195.       x := 0;
  196.       REPEAT
  197.         Box(x,y,Feld[x,y]);
  198.         INC(x);
  199.       UNTIL x=W;
  200.       INC(y);
  201.     UNTIL y=H;
  202.   END;
  203. END CheckLine;
  204.  
  205. (* $Debug= *)
  206.  
  207.  
  208. PROCEDURE Play(): BOOLEAN;  (* TRUE wenn Q gedrückt *)
  209.  
  210. VAR
  211.   Stein: INTEGER;
  212.   x,x2,y,y2,c: INTEGER;
  213.   TimeCnt: INTEGER;
  214.   Turn,NewTurn: INTEGER;
  215.   VHPosR[0DFF006H]: INTEGER;
  216.  
  217. BEGIN
  218.   g.SetAPen(rp,0);
  219.   g.RectFill(rp,0,0,w,h);
  220.  
  221.   x := 0;
  222.   REPEAT
  223.     y := 0;
  224.     REPEAT
  225.       Feld[x,y] := 0;
  226.       INC(y);
  227.     UNTIL y=H;
  228.     INC(x);
  229.   UNTIL x=W;
  230.  
  231.   Lines := 0; TimeCnt := 0;
  232.  
  233.   REPEAT
  234.     Stein := VHPosR MOD 7; c := Stein MOD 3 + 1; Turn := 0;
  235.     x := W DIV 2 - 1; IF Stein=0 THEN DEC(x) END;
  236.     y := 0;
  237.     LOOP
  238.       IF Collide(S[Stein,Turn],x,y) THEN EXIT END;
  239.       Draw(S[Stein,Turn],x,y-1,0);
  240.       Draw(S[Stein,Turn],x,y,c);
  241.       LOOP
  242.         Draw(S[Stein,Turn],x,y,c);
  243.         IF TimeCnt>=300 THEN DEC(TimeCnt,300); EXIT END;
  244.         REPEAT
  245.           e.WaitPort(window.userPort);
  246.           MyMsgPtr := e.GetMsg(window.userPort);
  247.         UNTIL MyMsgPtr#NIL;
  248.         MyMsg := MyMsgPtr^;
  249.         e.ReplyMsg(MyMsgPtr);
  250.         IF I.intuiTicks IN MyMsg.class THEN INC(TimeCnt,30+Lines) END;
  251.         IF I.vanillaKey IN MyMsg.class THEN
  252.           Draw(S[Stein,Turn],x,y,0);
  253.           CASE MyMsg.code OF
  254.           ORD('4'):
  255.             IF (x>0) AND NOT Collide(S[Stein,Turn],x-1,y) THEN DEC(x) END |
  256.           ORD('5'):
  257.             NewTurn := (Turn + 1) MOD 4;
  258.             x2 := x; y2 := y;
  259.             IF Stein=0 THEN
  260.               IF ODD(Turn) THEN IF x2=0 THEN x2 := -1 ELSE DEC(x2); INC(y2) END
  261.                            ELSE                            INC(x2); DEC(y2) END;
  262.             END;
  263.             IF NOT Collide(S[Stein,NewTurn],x2,y2) THEN
  264.               Turn := NewTurn;
  265.               x := x2;
  266.               y := y2;
  267.             END |
  268.           ORD('6'):
  269.             IF NOT Collide(S[Stein,Turn],x+1,y) THEN INC(x) END |
  270.           ORD(' '):
  271.             LOOP
  272.               Draw(S[Stein,Turn],x,y,c);
  273.               IF Collide(S[Stein,Turn],x,y+1) THEN EXIT END;
  274.               d.Delay(1);
  275.               INC(y);
  276.               Draw(S[Stein,Turn],x,y-1,0);
  277.             END;
  278.             EXIT |
  279.           ORD('q'): RETURN TRUE |
  280.           ELSE END;
  281.         END;
  282.         IF I.closeWindow IN MyMsg.class THEN RETURN TRUE END;
  283.       END;
  284.       INC(y);
  285.     END;
  286.     IF y>0 THEN
  287.       Do(S[Stein,Turn],x,y-1,c,AddIt);
  288.       CheckLine;
  289.     END;
  290.   UNTIL y=0;
  291.  
  292.   IF Lines>HiScore THEN HiScore := Lines END;
  293.  
  294.   d.Delay(30);
  295.  
  296.   RETURN FALSE;
  297. END Play;
  298.  
  299.  
  300. (*-------------------------------------------------------------------------*)
  301.  
  302.  
  303. BEGIN
  304.  
  305.   window := NIL; HiScore := 0; AllocPort := NIL; AudioOpen := FALSE;
  306.   NEW(AllocationMapPtr); NEW(RectTablePtr); NEW(AllocIOB); NEW(winTitle); NEW(fontName);
  307.   IF (AllocationMapPtr=NIL) OR (RectTablePtr=NIL) OR (AllocIOB=NIL) OR
  308.      (winTitle=NIL) OR (fontName=NIL) THEN
  309.     HALT(20);
  310.   END;
  311.  
  312. (*------  Open Audio-Device:  ------*)
  313.  
  314.   AllocPort := es.CreatePort("",0);
  315.   IF AllocPort=NIL THEN HALT(0) END;
  316.  
  317.   AllocIOB.request.message.node.pri  := -40;
  318.   AllocIOB.request.message.replyPort := AllocPort;
  319.   AllocationMapPtr^ := AllocationMap;
  320.   AllocIOB.data   := AllocationMapPtr;
  321.   AllocIOB.length := 4;
  322.  
  323.   IF (e.OpenDevice("audio.device",0,AllocIOB,LONGSET{})#0) OR
  324.      (AllocIOB.request.error = au.allocFailed)
  325.   THEN HALT(0) END;
  326.  
  327.   AudioOpen := TRUE;
  328.  
  329.   AllocIOB.request.command := e.write;
  330.   AllocIOB.request.flags   := SHORTSET{4};
  331.   RectTablePtr^ := RectTable;
  332.   AllocIOB.data            := RectTablePtr;
  333.   AllocIOB.length          := RectTableSize;
  334.   AllocIOB.period          := 4000;
  335.   AllocIOB.cycles          := 200;
  336.   AllocIOB.volume          := 64;
  337.  
  338. (*------  Open Window:  ------*)
  339.  
  340.   nw.leftEdge   := (g.gfx.normalDisplayColumns - (w+ 8)) DIV 2;
  341.   nw.topEdge    := (g.gfx.normalDisplayRows    - (h+24)) DIV 2;
  342.   nw.width      := w+8;
  343.   nw.height     := h+24;
  344.   nw.blockPen   := 1;
  345.   nw.idcmpFlags := LONGSET{I.closeWindow,I.vanillaKey,I.intuiTicks};
  346.   nw.flags      := LONGSET{I.windowClose,I.windowDepth,I.windowDrag,I.gimmeZeroZero,I.activate};
  347.   nw.type       := {I.wbenchScreen};
  348.   winTitle^ := "Tetriz";
  349.   nw.title      := winTitle;
  350.   IF I.int.libNode.version>=36 THEN
  351.     window := I.OpenWindowTags(nw,I.waInnerWidth, w,
  352.                                   I.waInnerHeight,h+10,
  353.                                   0 (* Utility.done *) );
  354.   ELSE
  355.     window := I.OpenWindow(nw);
  356.   END;
  357.   IF window=NIL THEN HALT(0) END;
  358.   rp := window.rPort;
  359.   fontName^ := "topaz.font";
  360.   attr.name := fontName;
  361.   attr.ySize := 8;
  362.   font := g.OpenFont(attr);
  363.   IF font=NIL THEN HALT(0) END;
  364.   g.SetFont(rp,font);
  365.  
  366. (*------  Start:  ------*)
  367.  
  368.   LOOP
  369.  
  370.     g.SetAPen(rp,0); g.SetDrMd(rp,g.jam1);
  371.     g.RectFill(rp,0,0,w,h);
  372.     g.SetAPen(rp,1);
  373.  
  374.     g.Move(rp, 20,20);  g.Text(rp,"S = Start",9);
  375.     g.Move(rp, 20,40);  g.Text(rp,"Q = Quit" ,8);
  376.     g.Move(rp, 20,60);  g.Text(rp,"© 1989 by F. Siebert",20);
  377.     g.Move(rp, 20,80);  g.Text(rp,"   AMOK Stuttgart",17);
  378.     g.Move(rp,  0,h+8); g.Text(rp,"Lines:"   ,6);
  379.     g.Move(rp,108,h+8); g.Text(rp,"Hi:"      ,3);
  380.     g.Move(rp,144,h+8); WriteInt(HiScore);
  381.  
  382.     REPEAT
  383.       REPEAT
  384.         e.WaitPort(window.userPort);
  385.         MyMsgPtr := e.GetMsg(window.userPort);
  386.       UNTIL MyMsgPtr#NIL;
  387.       MyMsg := MyMsgPtr^;
  388.       e.ReplyMsg(MyMsgPtr);
  389.     UNTIL LONGSET{I.intuiTicks}#MyMsg.class;
  390.  
  391.     IF I.vanillaKey IN MyMsg.class THEN
  392.       CASE MyMsg.code OF
  393.       ORD('s'): IF Play() THEN EXIT END |
  394.       ORD('q'): EXIT |
  395.       ELSE END;
  396.     ELSIF I.closeWindow IN MyMsg.class THEN
  397.       EXIT
  398.     END;
  399.  
  400.   END;
  401.  
  402. CLOSE
  403.  
  404.   IF window#NIL    THEN I.CloseWindow(window)    END;
  405.   IF AudioOpen     THEN e.CloseDevice(AllocIOB)  END;
  406.   IF AllocPort#NIL THEN es.DeletePort(AllocPort) END;
  407.   IF font#NIL      THEN g.CloseFont(font)        END;
  408.  
  409. END Tetriz.
  410.  
  411.